home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 August / Macworld (1997-08).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / fortranMode.tcl < prev    next >
Text File  |  1997-06-17  |  21KB  |  676 lines
  1. #=============================================================================
  2. # Fortran mode definition and support procs
  3. #
  4. # Features:
  5. # 1.  Keyword colorization (slightly customizable)
  6. # 2.  Fortran-sensitive shift right/left preserve columns 1-6
  7. # 3.  Auto-indentation
  8. # 4.  Line-breaking with Ctl-Opt-J (a la emacs)
  9. # 5.  Subroutine indexing
  10. # 6.  Cmd-double-click subroutine and include-file lookup
  11. # 7.  Customizable comment and continuation characters
  12. #
  13. #------------------------------------------------------------------------------
  14. # Author: Tom Pollard <pollard@chem.columbia.edu>
  15. #
  16. # To Do:  work around grep failure for Unix-format tag files
  17. #
  18. #  4/97 - Coloring bug fixed.
  19. #  1/96 - FortMarkFile no longer marks F90 "end subroutine ..." statements
  20. #         more F90 keywords (will they never cease?)
  21. #  1/96 - user-selectable comment and continuation characters
  22. #         complete F90 keyword set (Thomas Bewley <bewley@rayleigh.stanford.edu>) 
  23. #         F90 functions and comparison operators optionally colorized ( " " )
  24. #         more complete set of C preprocessor commands colorized
  25. #         fixed case-sensitivity problem in line-indent routines
  26. #  1/96 - minor FortDblClick bug fix
  27. # 12/95 - more complete keyword set for F90 and HPF (from Tom Scavo)
  28. # 12/95 - cpp keyword colorization (George Nurser <g.nurser@soc.soton.ac.uk>)
  29. #         cmd-dbl-click supports cpp #include now
  30. # 11/95 - added FortBreakLine
  31. #         fixed case-sensitivity bug
  32. # 10/95 - fixed Cmd-Dbl-Click handler to deal w/ new(?) tag file format and
  33. #            improve performance (fortFindSub)
  34. #  9/95 - fixed getFortPrev bug with numbered lines
  35. #       - shiftLeft/Right revert to normal behavior on ill-formatted lines
  36. #  8/95 - auto-indentation is finally speedy and robust
  37. #  5/95 - added Cmd-Dbl-Click handler
  38. #       - added auto-indentation
  39. # 12/94 - fixed funcExpr, FortMarkFile search expressions
  40. #       - changed comment character from 'C' to 'c' (should be case-insensitive!)
  41. #       - added 'include' keyword
  42. #       - added FortShiftRight and FortShiftLeft procs
  43. #------------------------------------------------------------------------------
  44.  
  45.  
  46. #================================================================================
  47. if {$startingUp} {
  48.     addMode Fort dummyFort {*.f *.inc *.INC *.fcm *.for *.FOR *.f9 *.f90 *.hpf } {}
  49.     return
  50. }
  51.  
  52.  
  53.  
  54. proc dummyFort {} {}
  55.  
  56. newModeVar Fort sortedIsDefault    {0} 1
  57. newModeVar Fort wordWrap        {0}    1
  58. newModeVar Fort funcExpr    {^[^cC*!][ \t]*(subroutine|[ \ta-z*0-9]*function|entry).*$} 0
  59. newModeVar Fort autoMark        {0}    1
  60. newModeVar Fort electricTab        {1}    1
  61.  
  62. # newModeVar Fort    prefixString    {c}    0
  63. newModeVar Fort    continueChar    {$}    0
  64. newModeVar Fort    commentChar    {c}    0
  65. newModeVar Fort    colorFuncs    {0}    1
  66. newModeVar Fort    colorOpers    {0}    1
  67.  
  68. newModeVar Fort indentComment    {0}    1
  69. newModeVar Fort markTag            {{}} 0
  70.  
  71. #=============================================================================
  72. # Colorize Fortran keywords
  73. #
  74. proc fortColorKeywords {{color blue} {comment red} {specialChars black}} {
  75.     global FortmodeVars
  76.  
  77.     set FortKeywords { 
  78.         allocatable allocate assign backspace block call character close common 
  79.         complex contains continue cycle data deallocate dimension do double else 
  80.         elseif end enddo endfile endif entry equivalence exit external extrinsic 
  81.         forall format function goto if implicit include inquire integer intent 
  82.         interface intrinsic logical module namelist nullify open optional 
  83.         parameter pause pointer precision print private program public pure read 
  84.         real recursive return rewind save sequence stop subroutine target then 
  85.         use where while write assignment case default elsewhere endfile go none 
  86.         operator procedure select to type
  87.     }
  88.     
  89.     if {$specialChars != "black"} {
  90.         regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords  -i {=}  -i {*}  -i {/}  -i {+}  -i {-}  -i {,}  -i {(} -i {)} -I $specialChars
  91.     } else {
  92.         regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords  
  93.     }
  94.     unset FortKeywords
  95. } 
  96.  
  97. #=============================================================================
  98. # Colorize selected C preprocessor keywords
  99. #
  100. proc fortColorCPP {{color green}} {
  101.     set CPPKeywords  {
  102.         #if #endif #include #else #define #undef #ifdef #ifndef
  103.     }
  104.     regModeKeywords -a  -k $color Fort $CPPKeywords
  105.     unset CPPKeywords
  106. }
  107.  
  108.  
  109. #=========================================================================
  110. # Colorize Fortran operators
  111. #
  112. proc fortColorOpers {{color green}} {
  113.     set FortOperators {
  114.         eq ne lt le gt ge not and or eqv neqv true false
  115.     }
  116.     regModeKeywords -a -k $color Fort $FortOperators
  117.     unset FortOperators
  118. }
  119.  
  120. #=========================================================================
  121. # Colorize Fortran function keywords
  122. #
  123. proc fortColorFuncs {{color green}} {
  124.     # Fortran bit functions
  125.     #
  126.     set BitKeywords {
  127.         bit_size btest iand ibclr ibits ibset ieor ior ishft ishftc mvbits not
  128.     }
  129.     regModeKeywords -a -k $color Fort $BitKeywords
  130.     unset BitKeywords
  131.     
  132.     # Fortran intrinsic functions
  133.     #
  134.     set IntrinsicKeywords {
  135.         abs acos aimag asin atan atan2 conjg cos cosh dble dim dprod exp ichar 
  136.         len lge lgt lle llt log log10 max min mod sign sin sinh sqrt tan tanh 
  137.         iabs dabs cabs dacos dint dnint dasin datan datan2 dcos ccos dcosh idim 
  138.         ddim dexp cexp ifix idint alog ddlog clog alog10 dlog10 max0 amax0 max1 
  139.         amax1 dmax1 min0 amin0 min1 amin1 dmin1 amod dmod idnint float sngl 
  140.         isign dsign dsin csin dsinh dsqrt csqrt dtan dtanh aint anint char cmplx 
  141.         index int nint achar adjustl adjustr all allocated any associated 
  142.         bit_size btest ceiling count cshift date_and_time digits dot_product 
  143.         eoshift epsilon exponent floor fraction huge iachar iand ibclr ibits 
  144.         ibset ieor ior ishft ishftc kind lbound len_trim logical matmul 
  145.         maxexponent maxloc maxval merge minexponent minloc minval modulo mvbits 
  146.         nearest not pack precision present product radix random_number 
  147.         random_seed range repeat reshape rrspacing scale scan selected_int_kind 
  148.         selected_real_kind set_exponent shape size spacing spread sum 
  149.         system_clock tiny transfer transpose trim ubound unpack verify
  150.     }
  151.     regModeKeywords -a -k $color Fort $IntrinsicKeywords
  152.     unset IntrinsicKeywords    
  153. }
  154.  
  155. fortColorKeywords blue red magenta
  156. fortColorCPP green
  157. if {$FortmodeVars(colorFuncs)} {
  158.     fortColorFuncs green
  159. }
  160. if {$FortmodeVars(colorOpers)} {
  161.     fortColorOpers green
  162. }
  163. #=============================================================================
  164. # Special Fortran keybindings
  165. #
  166. bind '\[' <c>  FortShiftLeft Fort
  167. bind '\[' <co> FortShiftLeftSpace Fort
  168. bind '\]' <c>  FortShiftRight Fort
  169. bind '\]' <co> FortShiftRightSpace Fort
  170.  
  171. bind '\t'       doATab Fort
  172. bind '\t' <o>     {doATab 1} Fort
  173. bind '\t' <z>     {doATab 1} Fort
  174.  
  175. bind 'j'  <zo> FortBreakLine Fort
  176.  
  177. trace variable FortmodeVars(commentChar) w shadowFort
  178. trace variable FortmodeVars(colorFuncs) w shadowFort
  179. trace variable FortmodeVars(colorOpers) w shadowFort
  180.  
  181. #=============================================================================
  182. # Update colorization when Fortran mode variables are changed
  183. #
  184. proc shadowFort {name1 name2 op} {
  185.     global HOME FortmodeVars
  186.     if {$name1 == "FortmodeVars" && $op == "w"} {
  187.         switch $name2 {
  188.             "colorFuncs"    {
  189.                 if {$FortmodeVars(colorFuncs)} {
  190.                     fortColorFuncs green
  191.                 } else {
  192.                     fortColorFuncs black
  193.                 }
  194.              }
  195.             "colorOpers"    {
  196.                 if {$FortmodeVars(colorOpers)} {
  197.                     fortColorOpers green
  198.                 } else {
  199.                     fortColorOpers black
  200.                 }
  201.              }
  202.             "commentChar" {    
  203.                 fortColorKeywords blue red magenta
  204.             }
  205.             default {
  206.                 return
  207.             }
  208.         }
  209.     }
  210. }
  211.  
  212. #=============================================================================
  213. #
  214. proc FortMarkFile {} {
  215.     global FortmodeVars
  216.     set tag [quoteExpr2 $FortmodeVars(markTag)]
  217.     
  218.     set pat0 {^.*(subroutine|.*function|entry|program).*$}
  219.     set pat1 {^[^cC*!]([ \ta-z*0-9]*)(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
  220.     set end [maxPos]
  221.     set pos 0
  222.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
  223.         regexp -nocase $pat1 [eval getText $mtch] allofit valtyp subtyp name
  224.         set start [lineStart [lindex $mtch 0]]
  225.         set next [nextLineStart $start]
  226.         set pos $next
  227.         if {! [regexp -nocase "end" $valtyp mtch]} {
  228.             set inds([lineStart $start]) $name
  229.         }
  230.         
  231.     }
  232.     
  233.     set pat2 "^(c+${tag})\[ \t\]*(\[^\n\r\]*\[^ \t\])\[^ \t\]*\$"
  234.     set pos 0
  235.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat2 $pos} mtch]} {
  236.         regexp -nocase $pat2 [eval getText $mtch] allofit cc comment
  237.         regsub -all {[\/\(\)]} $comment {} comment
  238.         set start [lindex $mtch 0]
  239.         set end [nextLineStart $start]
  240.         set pos $end
  241.         set inds([lineStart $start]) $comment
  242.     }
  243.     
  244.     if {[info exists inds]} {
  245.         foreach f [lsort -integer [array names inds]] {
  246.             set next [nextLineStart $f ]
  247.             setNamedMark $inds($f) $f $f $f
  248.         }
  249.     }
  250. }
  251.  
  252. #================================================================================
  253. # Block shift left and right for Fortran mode (preserves cols 1-6)
  254. #================================================================================
  255.  
  256. proc FortShiftLeft {} {
  257.     global shiftChar
  258.     doFortShiftLeft "\t"
  259.     
  260. }
  261. proc FortShiftLeftSpace {} {
  262.     global shiftChar
  263.     doFortShiftLeft " "
  264. }
  265.  
  266. proc doFortShiftLeft {shiftChar} {
  267.     set start [lineStart [getPos]]
  268.     set end [nextLineStart [expr [selEnd] - 1]]
  269.     if {$start >= $end} {set end [nextLineStart $start]}
  270.     
  271.     set text [split [getText $start [expr $end - 1]] "\r"]
  272.     
  273.     set textout ""
  274.     
  275.     set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
  276.     foreach line $text {
  277.         if {[regexp $pat $line mtch pref body]} {
  278.             if {[string index $body 0] == $shiftChar} {
  279.                 lappend textout $pref[string range $body 1 end]
  280.             } else {
  281.                 lappend textout $line
  282.             }
  283.  
  284.         } elseif {[string index $line 0] == $shiftChar} {
  285.             lappend textout [string range $line 1 end]
  286.  
  287.         } else {
  288.             lappend textout $line
  289.         }
  290.     }
  291.  
  292.     set text [join $textout "\r"]    
  293.     replaceText $start [expr $end - 1] $text
  294.     select $start [expr 1 + $start + [string length $text]]
  295. }
  296.  
  297. proc FortShiftRight {} {
  298.     global shiftChar
  299.     doFortShiftRight "\t"
  300.     
  301. }
  302. proc FortShiftRightSpace {} {
  303.     global shiftChar
  304.     doFortShiftRight " "
  305. }
  306.  
  307. proc doFortShiftRight {shiftChar} {
  308.     set start [lineStart [getPos]]
  309.     set end [nextLineStart [expr [selEnd] - 1]]
  310.     if {$start >= $end} {set end [nextLineStart $start]}
  311.     
  312.     set text [split [getText $start [expr $end - 1]] "\r"]
  313.     
  314.     set textout ""
  315.     
  316.     set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
  317.     foreach line $text {
  318.         if {[regexp $pat $line mtch pref body]} {
  319.             lappend textout $pref$shiftChar$body
  320.         } else {
  321.             lappend textout $shiftChar$line
  322.         }
  323.     }
  324.     
  325.     set text [join $textout "\r"]    
  326.     replaceText $start [expr $end - 1] $text
  327.     select $start [expr 1 + $start + [string length $text]]
  328. }
  329.  
  330. proc FortBreakLine {} {
  331.     global FortmodeVars
  332.     set pos [getPos]
  333.     set line [getText [lineStart $pos] [expr [nextLineStart $pos]-1]]
  334.     if {[regexp {^[cC*!]} $line char]} {
  335.         insertText "\n$char "
  336.     } else {
  337.         set char $FortmodeVars(continueChar)
  338.         insertText "\n     $char"
  339.     }
  340.     FortindentLine
  341. }
  342.  
  343. #=============================================================================
  344. # Cmd-double-clicking opens include files, jumps to subroutine definitions,
  345. # and follows tags.
  346. #
  347. proc FortDblClick {from to} {
  348.     global tagFile
  349.     set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
  350.     set incPat {^[^cC*!][ \t]*include[ \t]*['"]([^'"]+)['"]}
  351.  
  352.     # First check whether an 'include' was clicked
  353.     set line [getText [lineStart $from] [expr [nextLineStart $to] - 1]]
  354.     if {[regexp -nocase $incPat $line allofit fname]} {
  355.         set path [absolutePath $fname]
  356.         if {[catch {openFileQuietly $path}]} { 
  357.             message "include file \'$fname\' not found in source folder"
  358.         }
  359.         return
  360.     }
  361.     
  362.     select $from $to
  363.     set text [getSelect]
  364.     
  365.     # First check current file for subroutine definition,...
  366.     if {![catch {fortFindSub $text} mtch]} { 
  367.         regexp -nocase $pat1 [eval getText $mtch] allofit subtyp name
  368.         pushMark
  369.         display [lindex $mtch 0]
  370. #         eval select $mtch
  371.         message "press <Ctl .> to return to original cursor position"
  372.  
  373.     # ...then check tags file.
  374.     } else {
  375.         message "Searching tags file..."
  376.         set lines [grep "^$text'" $tagFile]
  377.         if {[regexp {'(.*)'} $lines dummy fname]} { 
  378.             pushMark
  379.             if {[string match "*$fname*" [winNames -f]]} {
  380.                 bringToFront $fname
  381.             } else {
  382.                 edit $fname
  383.             }
  384.             set inds [fortFindSub $text]
  385. #             set inds [search -s -f 1 -r 1 -i 1 "$pat1$text" 0]
  386.             display [lindex $inds 0]
  387. #             eval select $inds
  388.             message "press <Ctl .> to return to original cursor position"
  389.         }
  390.     }
  391. }
  392.  
  393. # Speedy search for a Fortran subroutine.  Performance is dramatically 
  394. # improved by scanning for the name alone first, rather than running 
  395. # complicated regexp search on the entire file.
  396. #
  397. proc fortFindSub {name} {
  398.     set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
  399.     set pos 0
  400.     while {![catch {search -s -f 1 -r 0 -m 0 -i 1 $name $pos} mtch]} {
  401.         set beg [lineStart [lindex $mtch 0]]
  402.         set end [expr [nextLineStart [lindex $mtch 1]] -1]
  403.         set line [getText $beg $end]
  404.         if {[regexp  -nocase $pat1$name $line allofit subtyp name]} {
  405.             return $mtch 
  406.         } else {
  407.             set pos [lindex $mtch 1]
  408.         }
  409.     }
  410.     error "Subroutine \"$name\" not found"
  411. }
  412.  
  413. #=============================================================================
  414. # Fortan auto-indentation
  415. #
  416. # Logic:
  417. #    0.    Identify previous line
  418. #            a) ignore comments and continuation lines
  419. #            b) if current line is a CONTINUE that matches a DO, use the
  420. #                first corresponding DO as the previous line
  421. #
  422. #    1.    Find leading whitespace for previous line
  423. #
  424. #    2.    Increase whitespace if previous line starts a block, i.e.,
  425. #            a) DO loop
  426. #            b) IF ... THEN 
  427. #            c) ELSE
  428. #
  429. #    3.    Decrease whitespace if current line ends a block, i.e.,
  430. #            a) ELSE || ENDIF || END IF || ENDDO || END DO
  431. #            b) <linenum> CONTINUE matching a preceding DO
  432. #
  433. #        or if previous line ends a DO loop on an executable statement, i.e.,
  434. #            c) <linenum> (not CONTINUE) matching a preceding DO
  435. #
  436. ####################################################################################
  437. # Fortan auto-indentation
  438. #
  439. proc FortindentLine {} {    
  440.     set bol [lineStart [getPos]]
  441.     set eol [expr [nextLineStart $bol] - 1]
  442.     Fortindent $bol $eol
  443. }
  444.  
  445. proc FortindentRegion {} {    
  446.     Fortindent [getPos] [selEnd]
  447. }
  448.  
  449. ####################################################################################
  450. # Fortan auto-indentation of a specified region
  451. #
  452. proc Fortindent {pos0 pos1} {
  453.     global fortDooz fortPrevLine fortTop msg
  454.     global FortmodeVars
  455.  
  456.     set tag [quoteExpr2 $FortmodeVars(markTag)]
  457.     set doComment $FortmodeVars(indentComment)
  458.  
  459.     # Define regexps
  460.     set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
  461.     set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
  462.     set mtPat {^[ \t]*$}
  463.     set tab "    "
  464.     
  465.     set contPat {^     ([^ \t\n\r])[^\r\n]*$}
  466.     set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
  467.     set comPat "^(\[cC*!\]+(${tag})?)(\[ \t\]*)(.*)\$"
  468.     set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
  469.     set tailPat {[^\r\n]*$}
  470.     
  471.     set bobPat {^(if[^\n\r]*then|else|do)}
  472.     set eobPat {^(end[ \t]*if|end[ \t]*do|else)}
  473.     set enddoPat {^(end[ \t]*do|continue)}
  474.     
  475. #     set fortTop [fortSubTop $pos0]
  476.     set fortTop -1
  477.     
  478.     catch {unset fortDooz}
  479.     set fortPrevLine ""
  480.     
  481.     # Loop over region line by line
  482.     set from [lindex [posToRowCol $pos0] 0]
  483.     set to [lindex [posToRowCol $pos1] 0]
  484.     
  485.     while {$from <= $to} {        
  486.         set msg "Indenting line $from"
  487.         message $msg
  488.         set bol [lineStart [rowColToPos $from 0]]
  489.         set eol [expr [nextLineStart $bol] - 1]
  490.         set thisLine [getText $bol $eol]
  491.         goto $bol
  492.         
  493.         # Check whether we're entering a new routine
  494.         #
  495.         if {[regexp $subPat $thisLine allofit subType subName]} {
  496.             # alertnote "entering subr: \/$subName\/"
  497.             set fortTop $bol
  498.             catch {unset fortDooz}
  499.         } 
  500.         
  501.         # Is the current line a comment line...
  502.         #        
  503.         if {[regexp $comPat $thisLine allofit cc tag pre body]} {
  504.             if {$FortmodeVars(indentComment) > 0} {
  505.                 set body [string trimright $body]
  506.                 # alertnote "comment line: \/$pre\/$body\/"
  507.                 set lwhite "$cc     "
  508.                 
  509.                 replaceText $bol $eol $lwhite$body
  510.             }
  511.             
  512.         # ... or a line of code (possibly empty)?
  513.         #    
  514.         } elseif {[regexp $lnumPat $thisLine allofit pre lnum post body]} {
  515.             set body [string trimright $body]
  516.             # alertnote "line: \/$pre\/$lnum\/$post\/$body\/"
  517.             
  518.             # is it a continuation line?
  519.             #
  520.             if {(![regexp {\t} $pre]) && ([string length $pre] == 5)} {
  521.                 set cont [string index $lnum$post$body 0]
  522.                 set body [string trimleft [string range $lnum$post$body 1 end]]
  523.             } else {
  524.                 set cont {}
  525.             }
  526.             # alertnote "cont: \/$cont\/"
  527.             
  528.             # get whitespace for preceding line
  529.             set enddo [getFortPrev $bol $lnum]
  530.             set lwhite [getFortLwhite $bol]
  531.             
  532.             # if this line ends a block, decrease the whitespace
  533.             if {[regexp $eobPat $body] || ($enddo && [regexp -nocase $enddoPat $body])} {
  534.                 set lwlen [expr [string length $lwhite] - 4]
  535.                 set lwhite [string range $lwhite 0 $lwlen]
  536.             } 
  537.             
  538.             if {[string length $lnum]} {
  539.                 if {[string index $lwhite 0] != $tab} {
  540.                     set lwhite [string range $lwhite [expr [string length $lnum] +1] end]
  541.                 }
  542.                 set lnum " $lnum"
  543.             }
  544.             # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
  545.             # message "$msg : replacing text      "
  546.             
  547.             if {[string length $cont]} {
  548.                 replaceText $bol $eol "     $cont$lwhite$body"    
  549.             } else {
  550.                 replaceText $bol $eol $lnum$lwhite$body
  551.                 if {[string length $body] > 0} {
  552.                     set fortPrevLine $lnum$lwhite$body
  553.                 }
  554.             }
  555.         } else {
  556.             # message "$msg : Couldn't parse line         "
  557.         }
  558.         
  559.         # message "$msg : Done                "
  560.         incr from
  561.     }
  562. }
  563.  
  564. proc getFortLwhite {bol} {
  565.     global fortDooz fortPrevLine fortTop msg
  566.     # Define regexps
  567.     set tab "    "
  568.     set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
  569.     set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
  570.     set bobPat {^(if[^\n\r]*then|else|do)}
  571.     set enddoPat {^(end[ \t]*do|continue)}
  572.     
  573.     if {[regexp $lnumPat $fortPrevLine allofit pre0 lnum0 post0 body0]} {
  574.         # alertnote "prevLine: \/$pre0\/$lnum0\/$post0\/$body0\/"
  575.         
  576.         if {[string length $lnum0]} {
  577.             if {[string index $post0 0] == $tab} {
  578.                 set lwhite $post0
  579.             } else {
  580.                 regsub -all {[0-9]} $pre0$lnum0$post0 { } lwhite
  581.             }
  582.         } else {
  583.             set lwhite $pre0
  584.         }
  585.         # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
  586.         # message "$msg : got lwhite (initial)"
  587.         
  588.         # if there's a line number and it's not a CONTINUE or ENDDO, 
  589.         # then check for a matching DO statement and adjust 
  590.         # indentation if found
  591.         #
  592.         if {[string length $lnum0] && ![regexp -nocase $enddoPat $body0]} {
  593.             if {[getFortPrev [lineStart [expr $bol - 1]] $lnum0]} {
  594.                 set lwlen [expr [string length $lwhite] - 4]
  595.                 set lwhite [string range $lwhite 0 $lwlen]
  596.  
  597.             }
  598.         }
  599.         
  600.         # If the preceeding line begins a block (IF-THEN, DO, or ELSE),
  601.         # then increase the whitespace
  602.         #    
  603.         if {[regexp -nocase $bobPat $body0]} {
  604.             set lwhite "$lwhite   "
  605.             
  606.             if {[regexp -nocase "$doPat\(\[0-9\]+\)" $body0 mtch donum]} {
  607.                 set eol [expr [nextLineStart $bol] - 1]
  608.                 set fortDooz($donum) [getText $bol $eol]
  609.             }
  610.         }
  611.         # message "$msg : got lwhite (final)  "
  612.     }
  613.     return "$lwhite"
  614. }
  615.  
  616. proc getFortPrev {bol lnum} {        
  617.     global fortDooz fortPrevLine fortTop msg
  618.     # Define regexps
  619.     set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
  620.     set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
  621.     set contPat {^     ([^ \t\n\r])[^\r\n]*$}
  622.  
  623.     # if there's a line number, check for a matching DO statement ...
  624.     if {[string length $lnum]} {
  625.         if {[lsearch [array names fortDooz] $lnum] >= 0} {
  626.             set fortPrevLine $fortDooz($lnum)
  627.             return 1
  628.         } else {
  629.             if {$fortTop < 0} {
  630.                 set fortTop [fortSubTop $bol]
  631.             }
  632.             if {![catch {search -s -f 0 -r 1 -i 1 -l $fortTop $doPat$lnum [expr $bol -1]} dolst]} {
  633.                 set fortPrevLine [eval getText $dolst]
  634.                 set fortDooz($lnum) $fortPrevLine
  635.                 # alertnote "doLine0: \/$fortPrevLine\/"
  636.                 return 1
  637.             }
  638.         }
  639.     }
  640.         
  641.     # ... otherwise find the first preceding non-comment, non-continuation line
  642.     if {[string length $fortPrevLine] == 0} {
  643.         if {[catch {
  644.             set lst [search -s -f 0 -r 1 -i 1 -s $bolPat [expr $bol-1]]
  645.             set fortPrevLine [eval getText $lst]
  646.             while {[regexp -nocase $contPat $fortPrevLine]} {
  647.                 set lst [search -s -f 0 -r 1 -i 1 $bolPat [expr [lindex $lst 0] - 1]]
  648.                 set fortPrevLine [eval getText $lst]
  649.             }
  650.         }]} {
  651.             # if search fails, we're at the top of a file, so reset indentation
  652.             set fortPrevLine "      continue"
  653.         }
  654.     }
  655.     
  656.     # alertnote "prevLine: \/$fortPrevLine\/"
  657.     # message "$msg : got prevLine"
  658.     return 0
  659. }
  660.  
  661. # Find the beginning of the current subroutine
  662. #
  663. proc fortSubTop {{pos 0}} {
  664.     if {$pos == 0} {
  665.         set pos [lineStart [getPos]]
  666.     }
  667.     set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
  668.     
  669.     if {![catch {search -s -f 0 -r 1 -m 0 -i 1 $subPat $pos} sublst]} {
  670.         # set subLine [eval getText $sublst]
  671.         # alertnote "subLine: \/$subLine\/"
  672.         return [lindex $sublst 0]
  673.     } else {
  674.         return 0
  675.     } 
  676. }